home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / copyalloc.c < prev    next >
C/C++ Source or Header  |  1992-07-07  |  20KB  |  867 lines
  1.  /*    
  2.   * Allocation routines for feel
  3.   *
  4.   */
  5.  
  6. /* what we need to stay ahead*/
  7. #include "defs.h"
  8. #include "structs.h"
  9. #include "funcalls.h"
  10. #include "global.h"
  11. #include "allocate.h" 
  12. #include "error.h"
  13. #include "table.h"
  14.  
  15. /* other junk */
  16. #include "copy.h"
  17.  
  18. #ifndef DEFAULT_HEAP_SIZE
  19. #define DEFAULT_HEAP_SIZE (4*1024*1024)
  20. #endif
  21.  
  22. #ifndef DEFAULT_STACK_SPACE_SIZE
  23. #define DEFAULT_STACK_SPACE_SIZE (1*1024*1024)
  24. #endif
  25.  
  26. #define N_SLOTS_IN_CLASS N_SLOTS_IN_STRUCT(struct class_structure)
  27. #define N_SLOTS_IN_THREAD N_SLOTS_IN_STRUCT(struct thread_structure)
  28.  
  29. #define ROUNDTO 8
  30. #define ROUND_ADDR(x) ((((int)x)&(ROUNDTO-1))==0 ? x : x+(ROUNDTO-((int)x&(ROUNDTO-1))))
  31.  
  32. #ifdef NODEBUG
  33. #define FPRINTF_GC_BUG(x) 
  34. #define GC_BUG(x)
  35. #else
  36. #define GC_BUG(x) x
  37. #define FPRINTF_GC_BUG(x) fprintf x
  38. #endif
  39.  
  40. LispObject static_ints;
  41.  
  42. void runtime_initialise_allocator(LispObject *stacktop)
  43. {
  44.   static void initialise_stack_space(int);
  45.   extern void init_allocator(int);
  46.   extern int command_line_heap_size;
  47.   extern int command_line_stack_space_size;
  48.   extern int command_line_cons_percentage;
  49.   extern int command_line_cons_cut_off;
  50.  
  51.   int heap,stack_space;
  52.   
  53.   heap = (command_line_heap_size == 0
  54.             ? DEFAULT_HEAP_SIZE 
  55.             : command_line_heap_size);
  56.  
  57.   if (heap < 50)
  58.     heap=heap*1024*1024;
  59.  
  60.  
  61.   {
  62.     extern int command_line_cons_percentage;
  63.     extern int command_line_cons_cut_off;
  64.     
  65.     if (command_line_stack_space_size < 50)
  66.       command_line_stack_space_size = command_line_stack_space_size*1024*1024;
  67.  
  68.     stack_space = (command_line_stack_space_size == 0
  69.            ? DEFAULT_STACK_SPACE_SIZE
  70.            : command_line_stack_space_size);
  71.   }
  72.  
  73.   init_allocator(heap); /* ifdef CGC this does nothing */
  74.   initialise_stack_space(stack_space); /* and this calls gc_init() */
  75.  
  76.   /* so if CGC is defined, all the above does is call gc_init() */
  77.  
  78.   /* Really need a smarter way of doing these... --- like do them last */
  79.   add_root((LispObject *) &state_dynamic_env);
  80.   add_root(&state_last_continue);
  81.   add_root(&state_handler_stack);
  82.   add_root(&state_current_thread);
  83.   allocate_static_integers(stacktop); /* calls gc_malloc*/
  84. }
  85.  
  86. char *allocate_space(LispObject *stacktop,int n)
  87. {
  88.   char* allocate_stack(LispObject *stacktop, int nbytes);  
  89.  
  90.   return allocate_stack(stacktop,n);
  91. }
  92.  
  93. void deallocate_space(LispObject*stacktop,char *addr,int siz)
  94. {
  95.   void deallocate_stack(LispObject *, char *, int);
  96.  
  97.   deallocate_stack(stacktop,addr,siz);
  98. }
  99. void runtime_initialise_collector(LispObject *stacktop)
  100. {
  101.  
  102. }
  103.  
  104. #define NOT_YET_DONE(name) \
  105. { fprintf(stderr,"%s: cannot alloc\n",name) ; return nil;}
  106.   
  107. LispObject Fn_cons(LispObject *stacktop)
  108. {
  109.   LispObject ans;
  110.  
  111.   ans = allocate_nbytes(stacktop+2,sizeof(struct cons_structure),TYPE_CONS); 
  112.   
  113.   lval_classof(ans)=Cons;
  114.   ans->CONS.car= *stacktop;
  115.   ans->CONS.cdr= *(stacktop+1);
  116.   
  117.   return ans;
  118. }
  119.  
  120. /* Optimised to allow easier code in a lot of places... */
  121. LispObject allocate_n_conses(LispObject *stacktop, int n)
  122. {    
  123.   LispObject xx;
  124.   int i;
  125. #ifdef NOWAY  
  126.   struct cons_structure *ptr;
  127.  
  128.   xx=allocate_cbytes(stacktop,n,sizeof(struct cons_structure),TYPE_CONS);
  129.   ptr= &(xx->CONS);
  130.   lval_classof(xx)=Cons;
  131.   ptr++;
  132.   for (i=1; i<n; i++)
  133.     {
  134.       ptr->header.class=Cons; /* XXX */
  135.       ptr->car=nil;    
  136.       (ptr[-1]).cdr=(LispObject)ptr;
  137.       ptr++;
  138.     }
  139.   
  140.   ptr[-1].cdr=nil;
  141.   return xx;
  142. #else
  143.   xx=nil;
  144.   for (i=0; i<n; i++)
  145.     {
  146.       xx=EUCALL_2(Fn_cons,nil,xx);
  147.     }
  148.       
  149.   return xx;
  150.  
  151. #endif
  152. }
  153.  
  154. LispObject allocate_n_envs(LispObject *stacktop, int n)
  155. {    
  156.   LispObject xx;
  157.   int i;
  158.   xx=0;
  159.   for (i=0; i< n; i++)
  160.     {
  161.       xx=allocate_env(stacktop,nil,nil,xx);
  162.     }
  163.  
  164.   return xx;
  165. }
  166.  
  167. LispObject allocate_class(LispObject *stacktop,LispObject class)
  168. {
  169.   LispObject ans;
  170.   int i;
  171.  
  172.   STACK_TMP(class);
  173.   if (class==NULL)
  174.     ans = allocate_nbytes(stacktop,sizeof(struct class_structure),TYPE_CLASS);
  175.   else 
  176.     ans = allocate_nbytes(stacktop,
  177.               sizeof(Object_t)+sizeof(LispObject)*class->CLASS.local_count,
  178.               TYPE_CLASS);
  179.   UNSTACK_TMP(class);
  180.   lval_classof(ans) = class;
  181.  
  182.   (ans->CLASS).name = unbound;
  183.   (ans->CLASS).superclasses = nil;
  184.   (ans->CLASS).subclasses = nil;
  185.   (ans->CLASS).slot_table = nil;
  186.   (ans->CLASS).slot_list = nil;
  187.   (ans->CLASS).direct_slot_list = nil;
  188.   (ans->CLASS).precedence = nil;
  189.   (ans->CLASS).local_count = 0;
  190.   
  191.   if (class!=NULL)
  192.     {
  193.       for (i=N_SLOTS_IN_CLASS ; i<class->CLASS.local_count ; i++)
  194.     slotref(ans,i) = nil;
  195.     }
  196.   return ans;
  197. }
  198.  
  199. LispObject allocate_instance(LispObject *stacktop,LispObject class)
  200. {
  201.   LispObject ans;
  202.   int i;
  203.  
  204.   STACK_TMP(class);
  205.  
  206.   ans=allocate_nbytes(stacktop,sizeof(Object_t)
  207.               +sizeof(LispObject)*class->CLASS.local_count,TYPE_INSTANCE);
  208.   UNSTACK_TMP(class);
  209.   lval_classof(ans)=class;
  210.  
  211.   for (i=0; i<class->CLASS.local_count; i++)
  212.     slotref(ans,i)=nil;
  213.  
  214.   return ans;
  215. }
  216.  
  217. LispObject allocate_thread(LispObject *stacktop,int stack_size, 
  218.                int gc_stack_size, int nslots)
  219. { 
  220.   char* allocate_stack(LispObject *stacktop, int nbytes);
  221.   /* xxx: need extra slots hack */
  222.   LispObject ans,cont;
  223.   int extra;
  224.  
  225.   extra=nslots>0? nslots-N_SLOTS_IN_THREAD: 0;
  226.   cont=allocate_continue(stacktop);
  227.   *stacktop=cont;
  228.   
  229.   
  230.   ans=allocate_nbytes(stacktop+1,
  231.               sizeof(struct thread_structure)+extra*sizeof(LispObject),
  232.               TYPE_THREAD);
  233.   cont = *stacktop;
  234.   *stacktop=ans;
  235.   lval_classof(ans) = Thread;
  236.  
  237.   (ans->THREAD).stack_size = stack_size;
  238.   (ans->THREAD).gc_stack_size = gc_stack_size;
  239.  
  240.   (ans->THREAD).fun = nil;
  241.   (ans->THREAD).args = nil;
  242.   (ans->THREAD).value = nil;
  243.  
  244.   (ans->THREAD).status = 0;
  245.  
  246.   (ans->THREAD).parent = nil;
  247.   (ans->THREAD).cochain = nil;
  248.   
  249.   (ans->THREAD).state = cont;
  250.   (ans->THREAD).stack_base = NULL;
  251.   (ans->THREAD).gc_stack_base = NULL;
  252.  
  253.   ans->THREAD.state->CONTINUE.thread=ans;
  254.  
  255. #ifdef MACHINE_ANY
  256.  
  257.   (ans->THREAD).stack_base = (int *) allocate_stack(stacktop+1,stack_size);
  258.   (ans->THREAD.state)->CONTINUE.gc_stack_pointer =
  259.     (ans->THREAD).gc_stack_base =
  260.       (LispObject *) allocate_stack(stacktop+1,gc_stack_size*sizeof(LispObject));
  261.   
  262.   fprintf(stderr,"{New stack: 0x%x->0x%x}", (ans->THREAD).gc_stack_base,
  263.        (ans->THREAD).gc_stack_base+gc_stack_size);
  264.   STACK_TMP(ans);
  265.   cont=EUCALL_2(Fn_cons,function_default_handler,nil);
  266.   UNSTACK_TMP(ans);
  267.   ans->THREAD.state->CONTINUE.handler_stack = cont;
  268.     
  269. #else
  270.  
  271.   ans->THREAD.stack_base = NULL;
  272.   ans->THREAD.gc_stack_base = NULL;
  273.   ans->THREAD.state->CONTINUE.gc_stack_pointer = NULL;
  274.   ans->THREAD.state->CONTINUE.handler_stack =
  275.        EUCALL_2(Fn_cons,function_default_handler,nil);
  276.  
  277. #endif
  278.   { /* ugh */
  279.     int i;
  280.     if (extra>0)
  281.       for(i=N_SLOTS_IN_THREAD; i<nslots; i++)
  282.     slotref(ans,i) = unbound;
  283.   }
  284.   return ans;
  285. }
  286.  
  287. LispObject allocate_vector(LispObject *stacktop,int size)
  288. {
  289.   LispObject ans;
  290.   int i;
  291.  
  292.   ans = allocate_nbytes(stacktop,sizeof(Object_t)+sizeof(int)+size*sizeof(LispObject),
  293.             TYPE_VECTOR);
  294.   
  295.   lval_classof(ans)= Vector;
  296.   
  297.   ans->VECTOR.length=size;
  298.  
  299.   for(i=0; i<size ; i++)
  300.     vref(ans,i)=nil;
  301.  
  302.   return ans;
  303. }
  304.  
  305. LispObject allocate_string(LispObject *stacktop, char *string, int len)
  306. {
  307.   LispObject ans;
  308.  
  309.   len++;
  310.   len=ROUND_ADDR(len);
  311.   ans = allocate_nbytes(stacktop,sizeof(Object_t)+sizeof(int)+len,
  312.             TYPE_STRING); 
  313.   
  314.   lval_classof(ans)=String;
  315.   ans->STRING.length= len;
  316.   stringof(ans)[len-1]=0;
  317.   strncpy(stringof(ans),string,len);
  318.  
  319.   return ans;
  320. }
  321.  
  322. LispObject allocate_symbol(LispObject *stacktop, char *str)
  323. {
  324.   int hash(char *); /* from tables.c */
  325.  
  326.   LispObject ans;
  327.   LispObject tmp;
  328.   
  329.   tmp=allocate_string(stacktop,str,strlen(str));
  330.   STACK_TMP(tmp);
  331.   ans=allocate_nbytes(stacktop,sizeof(struct symbol_structure),TYPE_SYMBOL);
  332.   UNSTACK_TMP(tmp);
  333.   
  334.   lval_classof(ans)=Symbol;
  335.   (ans->SYMBOL).lvalue = nil;
  336.   (ans->SYMBOL).lmodule = nil;
  337.   (ans->SYMBOL).gvalue = NULL;
  338.   (ans->SYMBOL).left = NULL;
  339.   (ans->SYMBOL).right = NULL;
  340.   (ans->SYMBOL).plist = nil;
  341.   (ans->SYMBOL).hash = hash(str);
  342.   ans->SYMBOL.pname= tmp;
  343.  
  344.   return ans;
  345. }
  346.  
  347. LispObject allocate_table(LispObject *stacktop, LispObject (*comp)(LispObject*))
  348. {
  349.   LispObject ans;
  350.  
  351.   ans=allocate_nbytes(stacktop,sizeof(struct table_structure),TYPE_TABLE);
  352.   
  353.   lval_classof(ans)=Table;
  354.   (ans->TABLE).comparator = comp;
  355.   (ans->TABLE).lisp_comparator = nil;
  356.   (ans->TABLE).tree = nil;
  357.  
  358.   return ans;
  359. }
  360.  
  361. LispObject allocate_module_function(LispObject *stacktop,
  362.                     LispObject mod,LispObject name,
  363.                     LispObject (*fun)(LispObject*),
  364.                     int code)
  365. {
  366.   LispObject ans;
  367.  
  368.   STACK_TMP(name); STACK_TMP(mod);
  369.   ans=allocate_nbytes(stacktop,sizeof(struct c_function_structure),TYPE_C_FUNCTION);
  370.   UNSTACK_TMP(mod); UNSTACK_TMP(name);
  371.   lval_classof(ans) = Function;
  372.  
  373.   ans->C_FUNCTION.name = name;
  374.   ans->C_FUNCTION.home = mod;
  375.   ans->C_FUNCTION.argtype = code;
  376.   ans->C_FUNCTION.env = NULL;
  377.  
  378.   ans->C_FUNCTION.func = fun;
  379.   
  380.   return ans;
  381. }
  382.  
  383. #ifdef NOLOWTAGINTS
  384. LispObject real_allocate_integer(LispObject *stacktop, int n)
  385. {
  386.   LispObject ans;
  387.  
  388.   if (n>=0 && n<STATIC_INTEGERS)
  389.     return vref(static_ints,n);
  390.  
  391.   ans=allocate_nbytes(stacktop,sizeof(struct integer_structure),TYPE_INT);
  392.  
  393.   lval_classof(ans)=Integer;
  394.   intval(ans)=n;
  395.  
  396.   return ans;
  397. }
  398. #endif
  399.  
  400. /* stubs to keep arith.c happy */
  401. LispObject allocate_ratio(LispObject *stacktop,LispObject m,LispObject n)
  402. {
  403.   NOT_YET_DONE("ratio");
  404. }
  405.  
  406. LispObject allocate_complex(LispObject *stacktop,LispObject m,LispObject n)
  407. {
  408.   NOT_YET_DONE("complex");
  409. }
  410.  
  411. LispObject allocate_float(LispObject *stacktop,double x)
  412. {
  413.   LispObject ans;
  414.  
  415.   ans=allocate_nbytes(stacktop,sizeof(struct float_structure),TYPE_FLOAT);
  416.  
  417.   lval_classof(ans)=Real;
  418.   ans->FLOAT.fvalue=x;
  419.   
  420.   return ans;
  421.   
  422. }
  423.  
  424. LispObject allocate_char(LispObject *stacktop, char x)
  425. {
  426.   LispObject ans;
  427.  
  428.   ans=allocate_nbytes(stacktop,sizeof(struct character_structure),
  429.               TYPE_CHAR);
  430.   lval_classof(ans)=Character;
  431.   ans->CHAR.font=0;
  432.   ans->CHAR.code=x;
  433.   return ans;
  434.   
  435. }
  436.  
  437. LispObject allocate_continue(LispObject *stacktop)
  438. {
  439.  
  440.   LispObject ans;
  441.  
  442.   ans=allocate_nbytes(stacktop,sizeof(struct continue_structure),TYPE_CONTINUE);
  443.  
  444.   lval_classof(ans) = Continue;
  445.  
  446.   (ans->CONTINUE).thread = nil;
  447.  
  448.   (ans->CONTINUE).value = nil;
  449.   (ans->CONTINUE).target = nil;
  450.  
  451.   /*  (ans->CONTINUE).machine_state; */
  452.   (ans->CONTINUE).gc_stack_pointer = NULL;
  453.   (ans->CONTINUE).dynamic_env = NULL;
  454.   (ans->CONTINUE).last_continue = nil;
  455.   (ans->CONTINUE).handler_stack = nil;
  456.  
  457.   (ans->CONTINUE).dp = nil;
  458.  
  459.   (ans->CONTINUE).live = FALSE;
  460.   (ans->CONTINUE).unwind = FALSE;  
  461.   
  462.   return ans;
  463. }
  464.  
  465. LispObject allocate_stream(LispObject *stacktop, FILE *file, int mod)
  466. {
  467.   LispObject ans;
  468.  
  469.   ans = allocate_nbytes(stacktop,sizeof(struct stream_structure),TYPE_STREAM);
  470.  
  471.   lval_classof(ans) = Object;
  472.   (ans->STREAM).handle = file;
  473.   (ans->STREAM).name = nil; /* Wah? */
  474.   (ans->STREAM).mode = mod;
  475.   (ans->STREAM).curchar = 0;
  476.   return ans;
  477.  
  478. }
  479.  
  480. LispObject allocate_env(LispObject *stacktop, LispObject name, 
  481.             LispObject value, LispObject prev)
  482. {
  483.   LispObject ans;
  484.  
  485.   STACK_TMP(prev); STACK_TMP(name); STACK_TMP(value);
  486.   ans=allocate_nbytes(stacktop,sizeof(struct envobject),TYPE_ENV);
  487.   UNSTACK_TMP(value); UNSTACK_TMP(name); UNSTACK_TMP(prev);
  488.   lval_classof(ans) = nil; /* ? */
  489.  
  490.   ans->ENV.variable = name;
  491.   ans->ENV.value = value;
  492.   ans->ENV.next = &prev->ENV;
  493.   ans->ENV.mutable = lisptrue;
  494.  
  495.   return ans;
  496. }
  497.  
  498. LispObject allocate_envimut(LispObject *stacktop, LispObject name, LispObject value, LispObject prev)
  499. {
  500.   LispObject ans;
  501.   
  502.   ans=allocate_env(stacktop,name,value,prev);
  503.   
  504.   ans->ENV.mutable = nil;
  505.   return ans;
  506. }
  507.  
  508. LispObject allocate_special(LispObject *stacktop, 
  509.                 LispObject name, 
  510.                 LispObject (*fn)(LispObject *))
  511. {
  512.   LispObject ans;
  513.  
  514.   STACK_TMP(name);
  515.   ans=allocate_nbytes(stacktop,sizeof(struct special_structure),TYPE_SPECIAL);
  516.   UNSTACK_TMP(name);
  517.  
  518.   lval_classof(ans) = Object;
  519.  
  520.   ans->SPECIAL.name  = name;
  521.   ans->SPECIAL.env   = NULL;
  522.   ans->SPECIAL.func  = fn;
  523.  
  524.   return(ans);
  525.  
  526. }
  527.  
  528.  
  529. LispObject allocate_i_function(LispObject *stacktop, LispObject mod, 
  530.                    LispObject env, int argcode)
  531. {
  532.   LispObject ans;
  533.  
  534.   STACK_TMP(mod); STACK_TMP(env);
  535.   ans=allocate_nbytes(stacktop,sizeof(struct i_function_structure),TYPE_I_FUNCTION);
  536.  
  537.   UNSTACK_TMP(env); UNSTACK_TMP(mod);
  538.   lval_classof(ans)=Function;
  539.   ans->I_FUNCTION.name=nil;
  540.   ans->I_FUNCTION.home = mod;
  541.   ans->I_FUNCTION.env = &env->ENV;
  542.   ans->I_FUNCTION.argtype = argcode;
  543.   
  544.   ans->I_FUNCTION.bvl = nil;
  545.   ans->I_FUNCTION.body = nil;
  546.  
  547.   return ans;
  548. }
  549.  
  550.  
  551. LispObject allocate_i_module(LispObject *stacktop, LispObject name)
  552. {
  553.   LispObject ans;
  554.   LispObject tmp1,tmp2;
  555.   
  556.   STACK_TMP(name);
  557.   tmp1 = (LispObject) allocate_table(stacktop, Fn_eq);
  558.   STACK_TMP(tmp1);
  559.   tmp2 = (LispObject) allocate_table(stacktop, Fn_eq);    
  560.   STACK_TMP(tmp2);
  561.   ans=allocate_nbytes(stacktop,sizeof(struct i_module_structure), TYPE_I_MODULE);
  562.   UNSTACK_TMP(tmp2);
  563.   UNSTACK_TMP(tmp1);
  564.   UNSTACK_TMP(name);
  565.   lval_classof(ans)=Object;
  566.   ans->I_MODULE.name = name;
  567.   ans->I_MODULE.home = nil;
  568.   ans->I_MODULE.exported_names = nil;
  569.   ans->I_MODULE.bounce_flag = FALSE;
  570.   ans->I_MODULE.imported_modules = nil; /* HACK !!! GC */
  571.   ans->I_MODULE.bindings = tmp2;
  572.   
  573.   return ans;
  574. }
  575.  
  576. #if (defined(WITH_BSD_SOCKETS) || defined(WITH_SYSTEMV_SOCKETS))
  577.  
  578. LispObject allocate_listener(LispObject *stacktop)
  579. {
  580.   LispObject ans;
  581.  
  582.   ans=allocate_nbytes(stacktop,sizeof(struct listener_structure), TYPE_LISTENER);
  583.   lval_classof(ans)=nil; /* will be set later */
  584.   return ans;
  585. }
  586.  
  587.  
  588. LispObject allocate_socket(LispObject *stacktop)
  589. {
  590.   LispObject ans;
  591.   
  592.   ans=allocate_nbytes(stacktop,sizeof(struct socket_structure), TYPE_SOCKET);
  593.   lval_classof(ans)=nil; /* will be set later */
  594.   return ans;
  595. }
  596. #endif
  597.  
  598. LispObject allocate_semaphore(LispObject *stacktop)
  599. {
  600.   LispObject ans;
  601.   
  602.   ans=allocate_nbytes(stacktop,sizeof(struct semaphore_structure), TYPE_SEMAPHORE);
  603.  
  604.   lval_classof(ans)=Object; /* Ugh */
  605.   system_allocate_semaphore(&(ans->SEMAPHORE.semaphore));
  606.  
  607.   return ans;
  608. }
  609.  
  610. LispObject allocate_static_vector(LispObject *stacktop,int nslots)
  611. {
  612.   LispObject space;
  613.   int i;
  614.  
  615.   space=(LispObject) allocate_space(stacktop,sizeof(Object_t)+sizeof(int)+nslots*sizeof(LispObject));
  616.   
  617.   for (i=0; i<nslots; i++)
  618.     vref(space,i)=NULL;
  619.  
  620.   lval_typeof(space)=TYPE_VECTOR|STATIC_TYPE;
  621.   lval_classof(space)=Vector;
  622.   gcof(space)=current_space();
  623.   space->VECTOR.length=nslots;
  624.  
  625.   return(space);
  626. }
  627.  
  628. /* These are never called */
  629. void deallocate_page(LispObject *stacktop, char *addr, int n)
  630. {
  631.   
  632. }
  633.  
  634. LispObject show_free_heap(LispObject *stacktop)
  635. {
  636.  
  637. }
  638.  
  639. LispObject show_free_space(LispObject *stacktop)
  640. {
  641.  
  642. }
  643.  
  644. void promote_free_space(LispObject *stacktop)
  645. {
  646.  
  647. }
  648.  
  649.  
  650. void allocate_static_integers(LispObject *stacktop)
  651. {
  652. #ifdef NOLOWTAGINTS
  653.   int i;
  654.  
  655.   static_ints=allocate_vector(stacktop,STATIC_INTEGERS);
  656.   for (i=0; i<STATIC_INTEGERS; i++)
  657.     {        /* alloc a big integer, then 'fix' it */
  658.       LispObject xx=real_allocate_integer(stacktop,STATIC_INTEGERS);
  659.       intval(xx)=i;
  660.       vref(static_ints,i)=xx;
  661.     }
  662.  
  663.   add_root(&static_ints);
  664. #endif
  665. }
  666.  
  667.  
  668. typedef struct free_list_struct
  669. {
  670.   int size;
  671.   struct free_list_struct *next;
  672. } *FreeList;
  673.  
  674. static SYSTEM_GLOBAL(FreeList, stack_chain);
  675.  
  676. static int free_count;
  677. static int nfrags;
  678.  
  679. #ifdef CGC
  680. void initialise_stack_space(int stackspace)
  681. {
  682.   gc_init();
  683. }
  684. #else
  685. #undef SYSTEM_MAX_SHARED_SIZE
  686. #define SYSTEM_MAX_SHARED_SIZE 512*1024
  687.  
  688. void initialise_stack_space(int stackspace)
  689. {
  690.   char *space;
  691.   int allocated=0;
  692.   FreeList *chain_end;
  693.   
  694.   SYSTEM_INITIALISE_GLOBAL(FreeList,stack_chain,NULL);
  695.  
  696.   chain_end=&SYSTEM_GLOBAL_VALUE(stack_chain);
  697.   nfrags=0;
  698.   while (allocated < stackspace)
  699.     {
  700.       space=system_malloc(SYSTEM_MAX_SHARED_SIZE);
  701.  
  702.       *chain_end=(FreeList)space;
  703.  
  704.       (*chain_end)->size= SYSTEM_MAX_SHARED_SIZE - sizeof(*chain_end);
  705.       (*chain_end)->next= NULL;
  706.       chain_end=&((*chain_end)->next);
  707.       free_count=SYSTEM_GLOBAL_VALUE(stack_chain)->size;
  708.       
  709.       allocated+=SYSTEM_MAX_SHARED_SIZE;
  710.       nfrags++;
  711.     }
  712. }
  713. #endif
  714.  
  715. void show_stack_space()
  716. {
  717.   fprintf(stderr,"Stack space: %d remaining, %d fragments\n",free_count, nfrags);
  718. }
  719.  
  720. /* use header as pointer to prevously allocated stack */
  721.  
  722. #ifdef CGC
  723. char* allocate_stack(LispObject *stacktop, int nbytes)
  724. {
  725.   return (char *)gc_malloc(nbytes);
  726. }
  727. #else
  728. char* allocate_stack(LispObject *stacktop, int nbytes)
  729. {
  730.   FreeList oldstack;
  731.   FreeList *walker;
  732.   char *ret;
  733.  
  734.   if (nbytes==0)
  735.     return NULL;
  736.  
  737.   system_open_semaphore(stacktop,&S_G_V(GC_sem)); 
  738.   walker= &SYSTEM_GLOBAL_VALUE(stack_chain);
  739.   nbytes=ROUND_ADDR(nbytes);
  740.  
  741.   free_count -= nbytes;
  742.  
  743.   while ( (*walker)!=NULL)
  744.     {
  745.       if ((*walker)->size+sizeof(*walker)==nbytes)
  746.     { 
  747.       ret= (char*) (*walker);
  748.       *walker=(*walker)->next;
  749.       nfrags--;
  750.       FPRINTF_GC_BUG((stderr,"{Cool stack: %x->%x}",ret,ret+nbytes));
  751.       GC_BUG(memset(ret,'S',nbytes));
  752.       system_close_semaphore(&S_G_V(GC_sem)); 
  753.       return ret;
  754.     }
  755.       if ((*walker)->size<nbytes)
  756.     {
  757.       FPRINTF_GC_BUG((stderr,"[Looking at: %x->%x (%d)]",*walker,(*walker)+(*walker)->size,
  758.               (*walker)->size));      
  759.       walker = &((*walker)->next);
  760.     }
  761.       else
  762.     {
  763.       ret= ((char *)((*walker)+1))+((*walker)->size-nbytes);
  764.       (*walker)->size=(*walker)->size-nbytes;
  765.       GC_BUG(memset(ret,'S',nbytes));
  766.       FPRINTF_GC_BUG((stderr,"{Alloc stack: %x->%x}",ret,ret+nbytes));
  767.       system_close_semaphore(&S_G_V(GC_sem)); 
  768.       return ret;
  769.     }
  770.     }
  771.   fprintf(stderr,"alloc stack: stack wimped out (%d remaining --- probably)\n",free_count);
  772.   system_close_semaphore(&S_G_V(GC_sem)); 
  773.   return NULL;
  774. }
  775. #endif
  776.  
  777. #ifdef CGC
  778. void deallocate_stack(LispObject *stacktop, char *addr,int nbytes)
  779. {
  780.  /* could use gc_free(object) here? */
  781. }
  782. #else
  783. void deallocate_stack(LispObject *stacktop, char *addr,int nbytes)
  784. {
  785.   FreeList old, walker;
  786.   /* Too damm lazy */
  787.   nbytes=ROUND_ADDR(nbytes);
  788.  
  789.   
  790.   system_open_semaphore(stacktop,&S_G_V(GC_sem)); 
  791.   walker=SYSTEM_GLOBAL_VALUE(stack_chain);
  792.   FPRINTF_GC_BUG((stderr,"{dealloc: %x->%x [%d]",addr,addr+nbytes,nbytes));
  793.   while (   ((char *)walker->next) < addr
  794.      && walker->next!=NULL)
  795.     {
  796.       /* sanity check */
  797. #if 0
  798.       if (walker >= walker->next)
  799.     { 
  800.       FPRINTF_GC_BUG((stderr,"Rats--- strange chain\n"));
  801.       system_lisp_exit(1);
  802.     }
  803. #endif
  804.       walker=walker->next;
  805.     }
  806.   /* 3 cases --- at the start */
  807.   if ( ((char *)(walker+1)) + walker->size == addr)
  808.     {
  809.       /* side check for end */
  810.  
  811.       if (walker->next!=NULL && addr+nbytes == (char *) walker->next)
  812.     {
  813.       walker->size = walker->size+nbytes
  814.         +sizeof(*walker)
  815.           +walker->next->size;
  816.       walker->next=walker->next->next;
  817.       free_count+=nbytes+sizeof(*walker);
  818.       nfrags--;
  819.       FPRINTF_GC_BUG((stderr,"Filler}"));
  820.     }
  821.       else    
  822.     {
  823.       walker->size=walker->size+nbytes;
  824.       free_count+=nbytes;
  825.       FPRINTF_GC_BUG((stderr,"Start}"));
  826.     }
  827.       system_close_semaphore(&S_G_V(GC_sem)); 
  828.       return;
  829.     }
  830.   /* at the end */
  831.   if ( walker->next!=NULL && addr+nbytes == (char *) walker->next)
  832.     {
  833.       old=walker->next;
  834.       walker->next=(FreeList) addr;
  835.       walker->next->size=nbytes+old->size;
  836.       walker->next->next=old->next;
  837.       free_count+=nbytes;
  838.       FPRINTF_GC_BUG((stderr,"End}"));
  839.       system_close_semaphore(&S_G_V(GC_sem)); 
  840.       return;
  841.     }
  842.   /* in the middle */
  843.   old=walker->next;      
  844.   walker->next=(FreeList) addr;
  845.   walker->next->next=old;
  846.   walker->next->size=nbytes-sizeof(*walker);
  847.   nfrags++;
  848.   free_count+=nbytes-sizeof(*walker);
  849.   FPRINTF_GC_BUG((stderr,"Middle}"));
  850.   system_close_semaphore(&S_G_V(GC_sem)); 
  851. }
  852. #endif 
  853.   
  854. int dump_obj(unsigned int *x,int s)
  855. {
  856.   int i;
  857.   
  858.   if (s>200) s=16;
  859.  
  860.   for (i=0; i<s ; i+=4)
  861.     fprintf(stderr,"0x%x: %x %x %x %x\n",
  862.         x+i,
  863.         (int)*(x+i),(int)*(x+i+1),(int)*(x+i+2),(int)*(x+i+3));
  864.   return s;
  865. }
  866.   
  867.